Sub 例2962()
 Sheets("Sheet1").Select
    ActiveCell.SpecialCells(xlLastCell).Select
    endr = ActiveCell.Row
      
 Range("e4").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=5, Criteria1:="Sold"
    Rows("4:" & endr).Select
    
    Selection.Delete Shift:=xlUp
    Range("J2").Select
    Selection.AutoFilter
    Range("A1").Select
End Sub 

Dim wsiz As Variant  '表の幅指定
' 
If InStr(1, dbas, "##", 1) > 0 Then
    If InStr(1, dbas, "WIDTH", 1) > 0 Then
	wsiz = Range(Cells(bro, 1), Cells(bro, 50)).Value
    End If
End If
'
’配列内容の処理例
          wsiz1 = InStr(1, wsiz(1, c), "WIDTH", 1)
          If wsiz1 > 0 Then
              wsiz2 = InStr(wsiz1, wsiz(1, c), "H", 1)
              wsiz(1, c) = Mid(wsiz(1, c), wsiz2 + 2)
          End If
          If wsiz(1, c) <> "" Then
            dbas = "<TD WIDTH=" & wsiz(1, c)
          End If

Sub 例2964()
If cn Mod 2 = 0 Then
    msg = "氏名をひらがな or カタカナで入力して下さい"
    namae = InputBox$(msg, "氏名(カナ)", "")
    If namae = "" Then
        Exit Sub
    End If
    namae = StrConv(namae, 16)
    namae = StrConv(namae, 8)
    namae = namae & "*"
    
    Range("C6").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=3, Criteria1:="=" & namae, Operator:=xlAnd
 Else
    ActiveSheet.AutoFilterMode = False
 End If
 cn = cn + 1
End Sub

(1)英文字で指定した列の数字化
Sub 例2965k1()
er = 0
msg = "選択する列のセルを指定して下さい。" & Chr(10) _
& "(A〜IVを入力して下さい＜大文字・小文字可＞)"
    scel = InputBox(msg, "セル指定")
    scel = StrConv(scel, 8)
    scel = StrConv(scel, 1)
    
If Len(scel) = 1 Then
    cel = Asc(scel) - 64
ElseIf Len(scel) = 2 Then
    c1 = Left(scel, 1): c2 = Right(scel, 1)
    c1a = Asc(c1) - 64
    c2a = Asc(c2) - 64
    If c1a > 0 And c1a < 28 Then
         If c2a > 0 And c2a < 28 Then
             cel = c1a * 26 + c2a
         Else
            er = 1
         End If
    Else
        er = 1
    End If
Else
    er = 1
End If
    If cel > 256 Then
        er = 1
    End If
    If er = 1 Then
        MsgBox "A〜IVの英文字を入力して下さい"
        Exit Sub
    End If
 MsgBox "指定した列は「" & cel & "」です"
End Sub
---------------------------------------------------------------
(2)　セルをマウスで選択
Sub 例2965k2()
    msg = "選択する列のセルを指定して下さい。" & Chr(10) _
    & "(マウスで指定し、行は何処でもよい)"
    On Error Resume Next
    Set scel = Application.InputBox(msg, "セル指定", Type:=8)
    On Error GoTo 0
    scel.Select
    cst = ActiveCell.Column
    MsgBox "指定した列は「" & cst & "」です"
End Sub

Sub Macro1()

ActiveCell.SpecialCells(xlLastCell).Select
      endr = ActiveCell.Row
      
For i = endr To 2 Step -1
    Cells(i, 2).Select
    If Selection.Interior.ColorIndex = 3 Then
        Rows(i).Select
        Selection.Delete Shift:=xlUp
    End If
Next
End Sub

Sub Macro1()
i = 1
For Each ex In ActiveSheet.ChartObjects
    obg(i) = ex.Name
   gifname = obg(i) & ".gif"
   ActiveSheet.ChartObjects(obg(i)).Chart.Export phn & "\" & gifname
Next
End Sub

Sub Macro2()
i = 1
For Each ex In ActiveSheet.ChartObjects
    obg(i) = ex.Name
   gifname = obg(i) & ".gif"
        gs1 = InStr(3, gifname, " ", 1)
      If gs1 > 0 Then
        gifname = Mid(gifname, 1, gs1 - 1) & Mid(gifname, gs1 + 1)
      End If
   ActiveSheet.ChartObjects(obg(i)).Chart.Export phn & "\" & gifname
Next
End Sub

Sub Macro3()
i = 1
For Each ex In ActiveSheet.ChartObjects
   gifname = "MyChart" & i & ".gif"
   ActiveSheet.ChartObjects(i).Chart.Export phn & "\" & gifname
    i = i + 1
Next
End Sub

下図のようにメニューを追加しましたが、本例は対象の ブックが閉じると追加したメニューも消えます（ブックに添付した感じ）。

このアイディアの何が素晴らしいかと言うとマクロで作成していない点です。 （マクロで、Temporary:=Trueを指定し作成れば追加した項目はExcelを閉じれば 消えますが、再表示は再度マクロを走らす必要あり）。（またExcel2000のマニアル で作成した場合は何時までも残り(消すまで）イライラする）


作り方：
[1]マクロのあるブックをExcel95形式で保存
[2]Excel95からそのブックを開く
[3]Excel95でメニューを追加し実行マクロを登録し保存する
[4]Excel2000でそのブックを開く
[5]Excel2000形式で保存する
この方式で作成したサンプルはKIgif です。興味のある方はダウンロードして見てください。

注意：本項目はアイディアとしては面白く「裏技」と言えるかもしれない。 しかし、Excel2000で公式に認めているメニューの表示方法ではなと思われるので あまり使用しない方がよいとかもしれない。（Excel2000で作成したファイルを Excel95で保存した時ユ−ザーフォーム等は消えてしまいます）

Sub Macro1()
fff = Application.GetOpenFilename(Title:="開くファイルを指定")
     If fff = "False" Then
        MsgBox "ファイルを１個指定して下さい"
        Exit Sub
     End If
' イベントマクロを無効にする
 Application.EnableEvents = False
'　Auto_Openを実行しない
 Workbooks.Open Filename:=fff, Editable:=True
End Sub

' イベントマクロを有効にする
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.EnableEvents = True
End Sub

Sub aaaa()
dta = "ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚ"
dtc = "abcdefghijklmnopqrstuvwxyz"
For i = 1 To 100
  Cells(i, 1) = LCase(Cells(i, 1))
Next
For i = 1 To 26
    dta1 = Mid(dta, i, 1)
    dtc1 = Mid(dtc, i, 1)
    Range(Cells(1, 1), Cells(100, 1)) _
    .Replace What:=dta1, Replacement:=dtc1, LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=True, MatchByte:=True
Next
End Sub

’Book1のプロシージャ
Public ddd As String
Sub Macrox()
    ddd = "ABCDE"
End Sub

゜-------------------------------------
’Book3のプロシージャ
Sub Macroy()
    Call Macrox
    MsgBox "Book1の変数ddd →　" & ddd
End Sub

以下参照の設定方法
(1)参照ブックを指定


対照のブックを開いてから、VBE画面にすると下記のプロジェクトが 表示されるので、参照先を選ぶ。


(2)参照ブックを指定


上記のように選択したら、メニューの「ツール」から「VBAProjectプロパティ」 を指定


(3)プロジェクト名の変更


デフォルトでは、ブックのプロジェクトは「「VBAProject」であり、 同一のプロジェクト名では参照を設定できないので左図の ダイアログでプロジェクト名を変更する。(名前は何でもようが、通常後で 判りやすいようにブック名にする）


(4)参照先にマークを付ける


次にプロジェクト画面の、実行するブック(本例はBook3)を指定し、メニューの 「ツール」[参照設定」をクリックすると左図になるので、参照先のプロジェクト名 にマークを付ける。

参照を設定しておけば、参章元(本例Book3)を開けば自動的に参照先(本例Book1) を開きます。（なお、参章元・参照先に同一名のプロシージャ名がある場合は、 それを呼び出す時はブック名・モジュール名の指定が必要です)

Sub Macro1()
ccc = 0

'フィルタ
    Range("A3").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=2, Criteria1:="あああ"
    Selection.AutoFilter Field:=3, Criteria1:="AAAAAA"

'あるセルの合計
    Range("A3").CurrentRegion.SpecialCells(xlVisible).Select
    For Each sel In Selection
        ccc = ccc + sel.Value
    Next
MsgBox ccc
Selection.AutoFilter
End Sub

Sub aaa()
Dim zu As Object
    For Each zu In ActiveSheet.Shapes
       shname = zu.Name
       If InStr(1, shname, "Button", 1) = 0 Then
          zu.Delete
       End If
    Next
End Sub

（2001/2/10　A.Uさんから下記メールが来たので作成）
出社時間と退勤時間で実務労働時間を出すマクロを教えてください。
１５分単位での区切り
○拘束時間が６時間未満だと休憩無しなので実務労働時間は５時間４５分以下
○拘束時間が６時間以上７時間未満だと休憩が３０分なので 　実務労働時間は５時間３０分以上６時間１５分
○拘束時間が７時間以上８時間未満だと休憩が４５分なので 　実務労働時間は６時間１５分以上７時間００分
○拘束時間が８時間以上だと休憩が１時間なので 　実務労働時間は７時間以上

出社時間と退社時間を入力すると実務労働時間が表示されるようにしたいのです。 入力は９：００だったら「0900」１８：００だったら「1800」

出勤時間が「0848」退勤時間が「1812」の場合は 出社時間は１２分早いが９：００、退勤時間は１２分オーバーしているが１８：００ と言う考えなので（どちらも１５分未満と言う事なので） 実務労働時間は８時間と言うようにしたのです。 また、出勤が「0912」だった場合は９:１５分と言う形です。

フレックス制なので出退勤の時間がばらばらで、人数も１００人を超えているので このマクロが出来ればかなり管理が出来るようになります。 何か良いアドバイスをいただけないでしょか？ エクセルは２０００を使っています。 お願いします。教えてください。

---

(1)使い方 ・上図のように作りました。B列の出社時間・C列の退社時間を入力すれば 自動的にD列へ勤労時間が表示されます。

・なお、依頼では入力は９：００だったら「0900」となっていますが、 Excelのシリアル時間をそのまま使用する関係で９：００は「09:00」 と入力すして下さい（もしどうしても「0900」と入れたいなら、 ユーザーフォームで「0900」と入力しセルには「09:00」と入るよう改善 して下さい）

・下記オブジェクトで、Sub 文字設定()は新規のファイルを作成した時 1度実行して下さい。Sub 再チェック()は特に実行する必要ありませんが、 もし、B列又はC列へ入力してもD列が変化しない場合実行して下さい （再帰呼び出し禁止のためEnableEvents = Falseにしてあるが、 エラー等発生した場合Excelのイベントが発生しない状態になって しまうため、もしそのようになったら「再チェック」を実施する）

・拘束時間が８時間以上の残業時間も休息時間が必要なはずですが、質問に なかったので折込んでありますん。
----------------------------------------------------------------
(2)マクロ説明
・Private Sub ・・・は対象シートのクラスモジュールへ貼り付けて 下さい。2列と3列のでを取り込むようになっています。
・他は標準モジュールへ貼り付ける。
・マクロのポイントとしては、Excelの1分は=1/24/60→0.000694444で シリアル値で各種処理をして最後に時間にしてあります。
・D列に拘束時間を出していますが、この表示は依頼にはなく半分 デバッグ用に付けたものです。要らない場合は'(不用の場合カット） と記述してある個所をカットして下さい。

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column = 2 Or Target.Column = 3 Then
    r = Target.Row
    Call zikan
End If
Application.EnableEvents = True
End Sub

Public r As Integer
Dim st As Date
Dim et As Date

Sub zikan()
Const m1 As Single = 0.000694444  '1分
Const m15 As Single = 0.010416667  '15分
Const m30 As Single = 0.02083332  '30分
Const m45 As Single = 0.03124998  '45分
Const h1 As Single = 0.041666667  '1H
Const h6 As Single = 0.250000002  '6H
Const h7 As Single = 0.291666669  '7H
Const h8 As Single = 0.333333336  '8H

    st = Cells(r, 2)
    et = Cells(r, 3)
'9:00前補正
    If st < TimeValue("9:00") Then
       st = TimeValue("9:00")
    End If
'スタートの15分補正
    st1 = Int(st / m15)
    st = (st1 + 1) * m15
'終了の15分補正
    et = et + m1
    et1 = Int(et / m15)
    et = (et1) * m15
    
'拘束時間
    soku1 = et - st
    soku3 = soku1    '(不用の場合カット）
'6H
    If soku1 < h6 Then
      GoTo pass1
    End If
'6H-7H
    If soku1 >= h6 And soku1 < h7 Then
        soku1 = soku1 - m30
        GoTo pass1
    End If
'7H-8H
    If soku1 >= h7 And soku1 < h8 Then
        soku1 = soku1 - m45
        GoTo pass1
    End If
'8H
    If soku1 >= h8 Then
        soku1 = soku1 - h1
    End If
    
pass1:
    soku2 = CDate(soku1)
    
    On Error Resume Next
       Cells(r, 4) = soku2
       Cells(r, 6) = soku3  '(不用の場合カット）
    If Err = 0 Then
       On Error GoTo 0
    ElseIf Err = 1004 Then
       On Error GoTo 0
    Else
       MsgBox "予期せぬエラー"
    End If
End Sub
  
Sub 文字設定()
    Columns("D:D").Select
    Selection.NumberFormatLocal = "h:mm"
    Range("D1").Select
'(不用の場合カット）
     Columns("F:F").Select
    With Selection.Font
        .Size = 8
    End With
    Selection.NumberFormatLocal = "h:mm"
    Range("F1").Select
End Sub
Sub 再チェック()
   Application.EnableEvents = True
Selection.SpecialCells(xlCellTypeLastCell).Select
      endr = ActiveCell.Row
For r = 2 To endr
    Call zikan
Next
End Sub

（2001/2/15　S.Zさんから下記メールが来たので作成）
ユーザーフォーム上にふたつのテキストボックスがあり、 それぞれ、シート１のＡ列とＢ列に入っているデータを記入し、コマンドボタンを押 すと、 そこから検索して、Ｃ列のデータを探して、ユーザーフォーム上の ラベル１に表示させたいのですが、どのようにすればよろしいのでしょうか？

---

説明
上図のようにダイアロルへ入力すると、左図のように表示するマクロの作り方を 説明します。

[1] aaa()実行でダイアログを表示
[2] 「検索」ボタンクリックでaaa1()実行


簡単なマクロであり下記を自由にコピーして活用して下さい。ただし、日付検索は セルの表示方法によっては検索出来ないので注意が必要。

[1]Format(UserForm1.TextBox1.Text, "m""月""d""日""") 表示：1月2日　可
[2]Format(UserForm1.TextBox1.Text, "m/d") 　　　　　表示：1/2 可
[3]Format(UserForm1.TextBox1.Text, "yy/m/d")　　　　表示：01/1/2 可

[4]Format(UserForm1.TextBox1.Text, "ge.m.d")　表示：H13.1.2 不可
[5]Format(UserForm1.TextBox1.Text, "yy/m/d")　表示：2001/1/2 不可
[6]Format(UserForm1.TextBox1.Text, "ggge""年""m""月""d""日""")表示：平成13年1月2日　不可

セルの表示が[1][2][3]は問題なし。[4][5][6]は手で「データ」「フィルタ」「オートフィルタ」 で行なった場合は問題ないが、何故かマクロでは抽出できない(Excel95から全バージョン同じ）

Sub aaa()
UserForm1.Show
End Sub

Sub aaa1()
dat = ""

UserForm1.TextBox1.Text = Format(UserForm1.TextBox1.Text, "m""月""d""日""")

hizuke = UserForm1.TextBox1.Text
meigara = UserForm1.TextBox2.Text
'フィルタ
Range("A3").Select
Selection.AutoFilter
    Selection.AutoFilter Field:=2, Criteria1:=hizuke, Operator:=xlAnd
    Selection.AutoFilter Field:=3, Criteria1:=meigara, Operator:=xlAnd
    
'C列データ取得
  Range("a4").CurrentRegion.SpecialCells(xlVisible).Select
   For Each sel In Selection
        r = sel.Row
        If r <> 2 Then
            dat = Cells(r, 4)
            Exit For
        End If
   Next sel
If dat = "" Then
   dat = "抽出条件のデータなし"
End If
UserForm1.Label1.Caption = dat
Range("A2").Select
'フィルタ戻す
Selection.AutoFilter
End Sub

テレワークならECナビ Yahoo 楽天 LINEがデータ消費ゼロで月額500円〜！
無料ホームページ 無料のクレジットカード 海外格安航空券　海外旅行保険が無料！ 海外ホテル